home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
xrs.bas
< prev
next >
Wrap
BASIC Source File
|
1985-07-21
|
15KB
|
335 lines
10 REM *** PROGRAM FOR XREF & LISTING BASIC (XRS) V-1.1 7/11/85
20 REM *** Written in BASIC. Should be compiled for speed.
30 REM *** Much of this program is from SOFTALK Feb. 83 Page 91. Additional
40 REM *** changes in the print routines by the Atlanta IBM SIG. Current
50 REM *** changes by G K Hale of Long Communications - Winston-Salem, NC
60 CLS
70 CLEAR
80 KEY OFF
90 PRINT "Program to XREF and print BASIC programs saved in ASCII format"
100 PRINT
110 DEFINT A-Z
120 PRINT "ASCII FILE TO BE PRINTED --- ";
130 LINE INPUT PROGRAM$
140 T$=TIME$:D$=DATE$
150 PG=1:NL=1
160 INPUT "Do you want LIST, XREF or BOTH (L/X/B) ";LX$
170 IF LX$="L" OR LX$="X" OR LX$="B" THEN GOTO 190
180 PRINT CHR$(7):GOTO 160
190 IF LX$="L" THEN GOTO 3190
200 IF LX$="X" THEN GOTO 230
210 LPRINT TAB(8);PROGRAM$;" Printed on ";D$;" at ";T$;TAB(60);"PAGE";PG
220 LPRINT:LPRINT
230 PRINT
240 '***---dimension arrays---***
250 TOT.V=9: MAX.V=TOT.V
260 DIM F$(9), VAR.REF(600,9)
270 DIM VAR.NAMES$(600), VAR.TYPE$(600), V.FILED(600), VAR.PTR(600)
280 DIM VARS.IN.ST$(30), JJ.PTR(36)
290 NUM.SKIP.WORDS=155: DIM SKIP.WORDS$(155)
300 GOSUB 1800 'INITIALIZATION
310 OPEN PROGRAM$ FOR INPUT AS #1 'Open input file
320 LINE INPUT #1,ST$ 'Read 1st BASIC statement
330 IF LX$="X" THEN GOTO 350
340 LPRINT ST$ 'Send 1st line to printer
350 OPEN "xref.wrk" AS #2 LEN =42 'Open work file
360 '***---field statements for work file---***
370 FIELD #2,2 AS IREC$, 20 AS F.N$
380 FIELD #2,22 AS D1$,2 AS F$(0),2 AS F$(1),2 AS F$(2),2 AS F$(3),2 AS F$(4)
390 FIELD #2,32 AS D1$,2 AS F$(5),2 AS F$(6),2 AS F$(7),2 AS F$(8),2 AS F$(9)
400 FIELD #2,22 AS D1$,2 AS F0$,2 AS F1$,2 AS F2$,2 AS F3$,2 AS F4$
410 FIELD #2,32 AS D1$,2 AS F5$,2 AS F6$,2 AS F7$,2 AS F8$,2 AS F9$
420 GOSUB 2110 'Get flag settings
430 GOTO 580
440 LPRINT TAB(8);PROGRAM$;" Printed on ";D$;" at ";T$;TAB(60);"PAGE";PG
450 LPRINT:LPRINT
460 RETURN
470 ' *********************
480 ' * MAIN LOOP *
490 ' *********************
500 '
510 IF EOF(1) GOTO 2230 'If end, go print
520 IF LX$="X" THEN GOTO 550
530 LET NL=NL+1
540 IF NL=54 THEN LET NL=1:PG=PG+1:LPRINT CHR$(12);:GOSUB 440
550 LINE INPUT #1,ST$ 'Read Basic statement into st$
560 IF LX$="X" THEN GOTO 580
570 LPRINT ST$ 'Send line to printer
580 VARS.IN.ST = 0 'Set variables in St$=0
590 FLAG.GO=FALSE 'Yes = goto,gosub, or return
600 IX=INSTR(ST$," ") 'Find first space in statement
610 LINE.NUM=VAL(LEFT$(ST$,IX-1)) 'Set line number
620 IF LX$="B" THEN GOTO 640
630 PRINT LINE.NUM;
640 IS=IX+1 'Set is to first char after space
650 LINE.LEN=LEN(ST$) 'line.len = length of statement
660 '
670 '*******************************************
680 '* Loop within statement *
690 '* looking for a charcater (a-z) *
700 '* or <"> or <'> *
710 '* Found: then I=position in st$ *
720 '*******************************************
730 '
740 FOR I = IS TO LINE.LEN
750 IF VAR$="REM" THEN LSET VAR$=" ": GOTO 510
760 'if "REM", skip
770 LSET I$=MID$(ST$,I) 'set I$ to char from statement
780 IF (I$ >="A" AND I$<="Z") GOTO 950 'If between A&Z then go
790 IF I$><D.Q$ GOTO 860 'Check for a literal ("xx")
800 J=INSTR(I+1,ST$,D.Q$) 'Get end of literal
810 IF J=0 THEN J=LINE.LEN
820 VAR$=MID$(ST$,I,J-I+1): J=J+1 'Set var$ to literal
830 VT$="L" 'Variable type is a Literal
840 KEEP=XREF.LITERALS 'Do we xref literals?
850 GOTO 1060
860 IF I$="'" GOTO 510 'found comment
870 NEXT
880 GOTO 510 'WE FELL THRU LOOP, THUS DONE WITH THIS STATEMENT
890 '
900 ' *********************************
910 ' * Loop within statement *
920 ' * Looking for end of variable *
930 ' *********************************
940 '
950 FOR J=I+1 TO LINE.LEN
960 LSET I$=MID$(ST$,J) 'Set I$ to char from statement
970 IF (I$>="A" AND I$<="Z") OR (I$>="0" AND I$<="9") GOTO 1010
980 IF INSTR(SPECIAL.CHARS$,I$)>0 GOTO 1000
990 GOTO 1020 'Var$ done
1000 IF I$="(" GOTO 1020 'var$ done
1010 NEXT J
1020 VAR$=MID$(ST$,I,J-1-I+1) 'set var$ to variable
1030 VT$="V" 'Variable type is a Variable
1040 FLAG.GO=(VAR$="GOSUB" OR VAR$="GOTO" OR VAR$="RETURN" OR VAR$="RESUME")
1050 GOSUB 1670 'check if we want to xref this
1060 IF NOT KEEP GOTO 1370
1070 '***---Already found this var$ in this statement?---***
1080 '***---if so then skip it---***
1090 FOR I=1 TO VARS.IN.ST
1100 IF VAR$=VARS.IN.ST$(I) GOTO 1370 'already used, so skip
1110 NEXT
1120 VARS.IN.ST=VARS.IN.ST+1
1130 VARS.IN.ST$(VARS.IN.ST)=VAR$ 'first time
1140 '***---Find first variable greater or equal to var$---***
1150 IF VAR$>="A" THEN VAR.SUB=55: GOTO 1180 'set starting point for
1160 IF VAR$>="1" THEN VAR.SUB=48: GOTO 1180 ' search thru chain
1170 IV=0: OLD.PTR=0: NEW.PTR=VAR.PTR(0): GOTO 1220
1180 IV=ASC(VAR$)-VAR.SUB
1190 OLD.PTR=JJ.PTR(IV-1)
1200 NEW.PTR=VAR.PTR(OLD.PTR)
1210 '***---Search thru chain of variables---***
1220 FOR I=1 TO VARS
1230 IF VAR.NAMES$(NEW.PTR)>=VAR$ GOTO 1290 'Found
1240 OLD.PTR=NEW.PTR: NEW.PTR=VAR.PTR(NEW.PTR)
1250 IF VAR.NAMES$(NEW.PTR)="" GOTO 1290 'End of list
1260 NEXT
1270 '***---Not found so add to end of list---***
1280 NEW.PTR=0: GOTO 1310
1290 IF VAR.NAMES$(NEW.PTR)=VAR$ THEN I=NEW.PTR: GOTO 1340
1300 '***var$ not found - create entry, set ptr
1310 VARS=VARS+1: I=VARS: VAR.PTR(OLD.PTR)=I
1320 VAR.PTR(I)=NEW.PTR: VAR.NAMES$(I)=VAR$: VAR.TYPE$(I)=VT$
1330 IF VAR$ > VAR.NAMES$(JJ.PTR(IV)) THEN JJ.PTR(IV)=I
1340 IF VAR.REF(I,0)=MAX.V THEN GOSUB 1560
1350 ENTRY=VAR.REF(I,0)+1
1360 VAR.REF(I,ENTRY)=LINE.NUM: VAR.REF(I,0)=ENTRY
1370 IS=J
1380 IF FLAG.GO GOTO 1410 'goto, gosub, or return?
1390 GOTO 740
1400 '***get statement numbers
1410 IF IS>=LINE.LEN GOTO 740
1420 FOR I=IS TO LINE.LEN
1430 LSET I$=MID$(ST$,I)
1440 IF I$>="0" AND I$<="9" GOTO 1480
1450 IF I$><"," AND I$><" " THEN IS=I: GOTO 740
1460 NEXT
1470 IS=I: GOTO 740
1480 FOR J=I+1 TO LINE.LEN
1490 LSET I$=MID$(ST$,J)
1500 IF I$<"0" OR I$>"9" GOTO 1520
1510 NEXT
1520 VAR$=MID$(ST$,I,J-I)
1530 VT$="N" 'Variable type is a line Number
1540 IF XREF.LINENUMS THEN GOTO 1160 ELSE IS=J: GOTO 1410
1550 '*** Write filled group, set up next
1560 V.FILED(I)=TRUE 'say we've written some on work file
1570 '---entry point 2
1580 '***---Write out array of line numbers to work file---***
1590 LSET IREC$=MKI$(I): LSET F.N$=VAR.NAMES$(I)
1600 FOR I2=0 TO MAX.V
1610 LSET F$(I2)=MKI$(VAR.REF(I,I2))
1620 NEXT
1630 REC=REC+1: PUT #2,REC
1640 VAR.REF(I,0)=0 'reset pointer to first in array
1650 RETURN
1660 '***---Search thru reserved words list---***
1670 FOR I=1 TO NUM.SKIP.WORDS
1680 IF SKIP.WORDS$(I)=VAR$ GOTO 1710
1690 NEXT
1700 KEEP=TRUE: RETURN
1710 KEEP=NOT(VAR$=SKIP.WORDS$(I))
1720 RETURN
1730 '***END
1740 CLOSE
1750 RESTORE
1760 PRINT:PRINT
1770 INPUT "PRINT ANOTHER FILE (Y/N) ";AN$
1780 IF AN$="Y" OR AN$="y" THEN GOTO 60
1790 END
1800 '*** Init ***
1810 TRUE=-1: FALSE=0
1820 I$=SPACE$(1) 'Set i$ to be 1 byte long
1830 D.Q$=CHR$(34) 'double quote
1840 SPECIAL.CHARS$="($!%#." 'Chars allowed in variable names
1850 '***---Basic commands that will not be XREF ---***
1860 FOR I=1 TO NUM.SKIP.WORDS
1870 READ SKIP.WORDS$(I)
1880 DATA "WAIT", "WHILE", "WEND", "XOR"
1890 DATA "AND", "AS", "DATA", "ELSE", "FOR", "GOSUB", "GOTO", "IF"
1900 DATA "STICK", "STOP", "SWAP", "TIME$", "USR", "VARPTR", "VARPTR$"
1910 DATA "RESUME", "RND", "RUN", "SCREEN", "SCRN", "SGN", "SOUND", "SPACE$"
1920 DATA "POKE", "PMAP", "POS", "PRESET", "RANDOMIZE", "RENAME", "RESET"
1930 DATA "NAME", "NEW", "OCT$", "ERROR", "OPTION" ,"BASE", "OUT", "PEEK"
1940 DATA "LSET", "RSET", "MERGE", "MKI$", "MKS$", "MKD$", "MOD", "MOTOR"
1950 DATA "INPUT$", "INSTR", "INT", "KILL", "LET", "LOC", "LOF", "LPOS"
1960 DATA "PSET", "PRESET", "PUT", "VIEW", "WINDOW", "HEX$", "IMP", "INP"
1970 DATA "EXP", "FIELD", "FIX", "FRE", "GET", "LINE", "PAINT", "POINT"
1980 DATA "DRAW", "END", "EQV", "ERR", "ERL", "PLAY", "TIMER", "PEN", "STRIG"
1990 DATA "LOCATE", "NEXT", "NOT", "OR", "PRINT", "RETURN", "THEN", "TO"
2000 DATA "CVD", "DATE$", "DEF" ,"DEFINT", "DEFSNG", "DEFDBL", "DEFSTR"
2010 DATA "CLEAR", "COLOR", "COM", "COMMON", "CSNG", "CSRLIN", "CVI", "CVS"
2020 DATA "BSAVE", "SAVE", "CALL", "CAS1", "CDBL", "CHAIN", "CINT", "CIRCLE"
2030 DATA "WIDTH", "WRITE", "SPC", "ABS", "ASC", "BEEP", "BLOAD", "LOAD"
2040 DATA "APPEND", "CHR$", "CLS", "DIM", "END", "EOF", "INKEY$", "INPUT"
2050 DATA "INT", "CLOSE" ,"KEY" ,"ON", "OFF", "LEFT$", "RIGHT$", "MID$"
2060 DATA "LEN", "LOG", "SIN", "COS", "ATN", "SQR" ,"LPRINT", "OPEN", "OUTPUT"
2070 DATA "READ", "RESTORE", "STEP", "STR$", "STRING$", "TAB", "USING", "VAL"
2080 NEXT
2090 RETURN
2100 '***Set flags***
2110 REM
2120 CK$="Y"
2130 XREF.LITERALS=(CK$="Y" OR CK$="y") 'set xref.literals
2140 CK$="Y"
2150 XREF.LINENUMS=(CK$="Y" OR CK$="y") 'Set Xref.linenums
2160 RETURN
2170 OPEN PROGRAM$ FOR INPUT AS #1
2180 LINE INPUT #1,ST$
2190 RETURN
2200 '*********************************
2210 '* Final Printout of XREF *
2220 '*********************************
2230 IF LX$="X" THEN GOTO 2250
2240 LPRINT CHR$(12)
2250 PCTR=0
2260 VT$="L"
2270 GOSUB 2950 'Heading Routine
2280 GOSUB 3020 'Subheading Routine
2290 '***---Begin Loop to Print All Stored Variables (VT$="L","N","V")---***
2300 I.PTR=VAR.PTR(0) 'Set starting point
2310 FOR JI=1 TO VARS 'MAINLINE LOOP
2320 IF VAR.TYPE$(I.PTR)><VT$ THEN VT$=VAR.TYPE$(I.PTR): GOSUB 3020
2330 'if ><, new subheading
2340 BNAME$=VAR.NAMES$(I.PTR) 'Load name in print buffer
2350 IF NOT V.FILED(I.PTR) GOTO 2450 'Skip work file retrieval
2360 FOR IR=1 TO REC 'Read wrk file til match
2370 GET #2, IR
2380 IREC=CVI(IREC$)
2390 IF IREC><I.PTR GOTO 2440 'Non-matching record
2400 FOR I2=1 TO MAX.V 'Found match
2410 XREF=CVI(F$(I2)) 'set Buffer REFerence number
2420 GOSUB 2580 'Load Print Buffer
2430 NEXT I2
2440 NEXT IR
2450 FOR I2=1 TO VAR.REF(I.PTR,0) 'Loop thru vars in memory
2460 XREF=VAR.REF(I.PTR,I2) 'set Buffer REFerence number
2470 GOSUB 2580 'Load Print Buffer
2480 NEXT I2 'END MAINLINE LOOP
2490 GOSUB 2650 'Clear buffer of this var
2500 I.PTR=VAR.PTR(I.PTR) 'Set pointer to next var
2510 NEXT JI 'END MAINLINE LOOP
2520 GOSUB 2650 'Print Final Line from Buffer
2530 GOSUB 3160 'Space out final page
2540 GOTO 1740
2550 '*********************
2560 '* LOAD PRINT BUFFER *
2570 '*********************
2580 IF BREF.SUB>7 THEN GOSUB 2650: BNAME$="" 'Line is full, so print
2590 BREF(BREF.SUB)=XREF 'Load buffer with next refd line
2600 BREF.SUB=BREF.SUB+1
2610 RETURN
2620 '*********************
2630 '* PRINT DETAIL LINE *
2640 '*********************
2650 IF LCTR>60 GOTO 2660 ELSE 2700 'Check for end of page
2660 GOSUB 3160 'Finish this page
2670 GOSUB 2950 'Heading Routine
2680 GOSUB 3020 'Subheading Routine
2690 GOTO 2650
2700 N.LEN=LEN(BNAME$) 'Measure name length
2710 IF N.LEN=0 THEN LPRINT SPC(28);: GOTO 2830 'No name on this call
2720 IF N.LEN>16 GOTO 2730 ELSE 2780 'Long name, give it a whole print line
2730 LPRINT SPC(8);BNAME$
2740 BNAME$="" 'reinit buffer name
2750 LCTR=LCTR+1
2760 LPRINT SPC(28);
2770 GOTO 2830
2780 FOR D=N.LEN+1 TO 20 'Normal size name
2790 DOT$=DOT$+"."
2800 NEXT D
2810 LPRINT SPC(8);BNAME$;DOT$;
2820 BNAME$="": DOT$="" 'reinit buffer name area
2830 FOR R=0 TO 7 'print references from buffer
2840 IF BREF(R)=0 GOTO 2880 'done
2850 LPRINT USING " #####";BREF(R); 'print line number
2860 BREF(R)=0 'reinit buffer ref number
2870 NEXT R
2880 LPRINT
2890 LCTR=LCTR+1
2900 BREF.SUB=0 'reinit buffer pointer
2910 RETURN
2920 '*******************
2930 '* Heading Routine *
2940 '*******************
2950 PCTR=PCTR+1
2960 LPRINT TAB(10);PROGRAM$;" XREF Printed on ";D$;" at ";T$;TAB(64);"PAGE"; PCTR
2970 LCTR=8
2980 RETURN
2990 '***********************
3000 '* Sub-heading Routine *
3010 '***********************
3020 IF VT$=PREV.VT$ GOTO 3040
3030 IF BREF(0)><0 THEN GOSUB 2650 'clear buffer's detail line
3040 IF LCTR+4>57 THEN GOSUB 3160: GOSUB 2950 'Test end of page
3050 IF VT$="L" THEN SUBHEAD$="LITERALS": GOTO 3080
3060 IF VT$="N" THEN SUBHEAD$="LINE NUMBERS": GOTO 3080
3070 IF VT$="V" THEN SUBHEAD$="VARIABLES": GOTO 3080
3080 LPRINT: LPRINT
3090 LPRINT SPC(40-(LEN(SUBHEAD$)/2));SUBHEAD$;
3100 IF VT$=PREV.VT$ THEN LPRINT " (Cont.)";
3110 PREV.VT$=VT$
3120 LPRINT: LPRINT
3130 LCTR=LCTR+4
3140 RETURN
3150 '***---End Page Routine---***
3160 LPRINT CHR$(12);
3170 LCTR=0
3180 RETURN
3190 '***************************************************
3200 '* This routine used when LIST only is requested *
3210 '***************************************************
3220 OPEN PROGRAM$ FOR INPUT AS #1
3230 LPRINT TAB(8);PROGRAM$;" Printed on ";D$;" at ";T$;TAB(60);"PAGE";PG
3240 LPRINT:LPRINT
3250 LINE INPUT #1,FI$
3260 LPRINT FI$
3270 IF EOF(1) THEN GOTO 3310
3280 LET NL=NL+1
3290 IF NL=54 THEN LET NL=1:PG=PG+1:LPRINT CHR$(12);:GOTO 3230
3300 GOTO 3250
3310 LPRINT CHR$(12);
3320 GOTO 1740
65399 '** DONE - PRESS ENTER TO RETURN TO MENU **